#|___________________________________________________________________ 
 | 
 | ViSta - The Visual Statistics System
 | Copyright (c) 1991-2000 by Forrest W. Young
 | For further information contact the author 
 |
 | logobj1.lsp This file contains code for the vista logo
 |
 | NOTE: THIS IS THE 4-DIMENSIONAL VERSION OF THE CODE
 | DATING FROM OCTOBER 2000. THE 3-D VERSION IS MUCH MORE MATURE
 | THOUGH THERE ARE ONLY FEW DIFFERENCES IN GLIDE FUNCTION 
 | THERE MAY BE A FEW CHANGES IN OTHER FUNCTIONS...IM NOT SURE
 |___________________________________________________________________ 
 |#
;(debug)
;(listeners)
;(verbose t)

(setf *real-screen-size* (screen-size))

#+containers
(defmeth graph-window-proto :front-window ()
  (send self :show-window)
  (send self :top-most t)
  (send self :top-most nil))

(defun make-logo (&key window (message-number 1) about show margin copyright-at-top
                       (size (list 440 220)) scale glideing full-screen 
                       (back-color 'white) (draw-color 'black)
                       (container nil) (free nil) (pop-out nil) (type 0)
                       (location (floor (/ (- *real-screen-size* (list 440 220)) 2))))
  (let ((object (send logo-proto :new 4 :window window :show show :go-away nil
                      :scale scale :glideing glideing :about about 
                      :container container :free free :pop-out pop-out :type type
                      :message-number message-number  
                      :full-screen full-screen
                      :draw-color draw-color
                      :back-color back-color
                      :copyright-at-top copyright-at-top 
                      :margin margin :location location :size size)))
    (send object :menu nil)
    object))

(defproto logo-proto 
  '(showing dynamic showable frames-per-rotation frames-per-second copyright-flag
            transf prev-text c d e ssq-transf knt scale0 count comment-text
            message-number lines nlines nclicks ready glideing about text-store
            screen-saver start-time count-time loading-files buffer idle-start-time
            simple-write-flag copyright-at-top back-color-default draw-color-default
            p x-lov animate x y pause show-time) ()
  graph-proto
  )

(defmeth logo-proto :isnew 
  (dims &key (window nil) (show nil) (go-away t) (size (list 500 250))
        (message-number 1) (about nil) (container nil) (free nil) (pop-out nil)
        (location)
        (split) (type 3) (draw-color 'black) (back-color 'white)
        (margin nil) (scale nil) (glideing nil) (loopknt 0) (maxline 0)
        (copyright-at-top nil) (full-screen nil)
        )
  (unless location (setf location (floor (/ (- (screen-size) size) 2))))
  (unless split
          #+containers
          (progn
           (unless container
                   (setf container
                         (send container-proto :new type :outofclientwindow free
                               :localmenu nil
                               :size size :location location :show nil)))
           (enable-container container))
          (let ((object (if window window
                            (call-next-method dims :show nil :go-away go-away
                                              :size size :location location :menu nil)))
                )
            (send object :draw-color-default draw-color)
            (send object :back-color-default back-color)
            (send object :draw-color draw-color)
            (send object :back-color back-color)
            (reset-graphics-buffer)
            (send object  :redraw)
            #+containers
            (progn (disable-container)
                   (setf *logo-container* container)
                   (cond
                     (pop-out
                      (send object :pop-out t)
                      (send container :hide-window)
                      (apply #'send object :location location)
                      )
                     ((equal container *desktop-container*)
                      )
                     (free
                      (send object :location 4 22)
                      (defmeth object :show-window ()
                        (call-next-method)
                        (send container :show-window))
                      (defmeth object :remove ()
                        (send container :close))
                      (defmeth object :title (string)
                        (send container :title string))
                      (defmeth object :size (&rest args)
                        (cond
                          (args 
                            (apply #'call-next-method args)
                            (apply #'send container :size args))
                          (t (send container :size))))
                      (defmeth object :location (&rest args)
                        (if args
                            (apply #'send container :location args)
                            (send container :location)))
                      )))
            
            (send object :buffer 
                  (list "ViSta: The Visual Statistics System" 
                        *copyright-string* *version-string* 
                        *vista-website* *email* 
                        nil nil nil nil nil    nil nil nil nil nil 
                        nil nil nil nil nil))
            (send object :about about)
            (send object :copyright-at-top copyright-at-top)
            #+msdos (send object :new-menu nil :items nil)
            (send object :title "ViSta: The Visual Statistics System")
            
            (if (= *color-mode* 0) 
                (send object :use-color nil)
                (send object :use-color t))

            (send object :message-number message-number)
            
            (when full-screen
                  (apply #'send object :size (+ (send object :size) '(36 36)))
                  (send object :location 0 0))
            (when show
                  (send object :show-window))
            (if margin
                (apply #'send object :margin margin)
                (send object :margin 0 40 0 20))
            (send object :knt 0)
            (send object :count 0)
            (send object :glideing glideing)
            (send object :line-data)
            (send object :draw-logo)
            (send object :fill-logo)
            (send object :nlines (send object :num-lines))
           ; (send object :scale-type 'variable)
            (when scale
                  (send object :scale (iseq dims) 
                        (send object :scale (iseq dims) scale)))
            (send object :showing t)
            (send object :nclicks 0)
            object)))

(defmeth logo-proto :buffer (&optional (string-list nil set))
  (if set (setf (slot-value 'buffer) string-list))
  (slot-value 'buffer))

(defmeth logo-proto :idle-start-time (&optional (time nil set))
  (if set (setf (slot-value 'idle-start-time) time))
  (slot-value 'idle-start-time))

(defmeth logo-proto :draw-color-default (&optional (color-symbol nil set))
  (if set (setf (slot-value 'draw-color-default) color-symbol))
  (slot-value 'draw-color-default))

(defmeth logo-proto :back-color-default (&optional (color-symbol nil set))
  (if set (setf (slot-value 'back-color-default) color-symbol))
  (slot-value 'back-color-default))

(defmeth logo-proto :screen-saver (&optional (logical nil set))
  (if set (setf (slot-value 'screen-saver) logical))
  (slot-value 'screen-saver))

(defmeth logo-proto :loading-files (&optional (logical nil set))
  (if set (setf (slot-value 'loading-files ) logical))
  (slot-value 'loading-files ))

(defmeth logo-proto :about (&optional (logical nil set))
  (if set (setf (slot-value 'about) logical))
  (slot-value 'about))

(defmeth logo-proto :glideing (&optional (logical nil set))
  (if set (setf (slot-value 'glideing) logical))
  (slot-value 'glideing))

(defmeth logo-proto :showing (&optional (logical nil set))
  (if set (setf (slot-value 'showing) logical))
  (slot-value 'showing))

(defmeth logo-proto :showable (&optional (logical nil set))
  (if set (setf (slot-value 'showable) logical))
  (slot-value 'showable))

(defmeth logo-proto :dynamic (&optional (logical nil set))
  (if set (setf (slot-value 'dynamic) logical))
  (slot-value 'dynamic))

(defmeth logo-proto :ready (&optional (logical nil set))
  (if set (setf (slot-value 'ready) logical))
  (slot-value 'ready))

(defmeth logo-proto :simple-write-flag (&optional (logical nil set))
  (if set (setf (slot-value 'simple-write-flag) logical))
  (slot-value 'simple-write-flag))

(defmeth logo-proto :copyright-flag (&optional (logical nil set))
  (if set (setf (slot-value 'copyright-flag ) logical))
  (slot-value 'copyright-flag))

(defmeth logo-proto :frames-per-rotation (&optional (number nil set))
  (if set (setf (slot-value 'frames-per-rotation) number))
  (slot-value 'frames-per-rotation))

(defmeth logo-proto :frames-per-second (&optional (number nil set))
  (if set (setf (slot-value 'frames-per-second) number))
  (slot-value 'frames-per-second))

(defmeth logo-proto :show-time (&optional (number nil set))
  (if set (setf (slot-value :show-time) number))
  (slot-value ':show-time))

(defmeth logo-proto :pause (&optional (number nil set))
  (if set (setf (slot-value 'pause) number))
  (slot-value 'pause))

(defmeth logo-proto :transf (&optional (matrix nil set))
  (if set (setf (slot-value 'transf) matrix))
  (slot-value 'transf))

(defmeth logo-proto :ssq-transf (&optional (number nil set))
  (if set (setf (slot-value 'ssq-transf) number))
  (slot-value 'ssq-transf))

(defmeth logo-proto :text-store (&optional (info nil set))
  (if set (setf (slot-value 'text-store) info))
  (slot-value 'text-store))

(defmeth logo-proto :scale0 (&optional (number nil set))
  (if set (setf (slot-value 'scale0) number))
  (slot-value 'scale0))

(defmeth logo-proto :knt (&optional (number nil set))
  (if set (setf (slot-value 'knt) number))
  (slot-value 'knt))

(defmeth logo-proto :count (&optional (number nil set))
  (if set (setf (slot-value 'count) number))
  (slot-value 'count))

(defmeth logo-proto :lines (&optional (list nil set))
  (if set (setf (slot-value 'lines) list))
  (slot-value 'lines))

(defmeth logo-proto :nlines (&optional (list nil set))
  (if set (setf (slot-value 'nlines) list))
  (slot-value 'nlines))

(defmeth logo-proto :nclicks (&optional (number nil set))
  (if set (setf (slot-value 'nclicks) number))
  (slot-value 'nclicks))

(defmeth logo-proto :message-number (&optional (number nil set))
  (if set (setf (slot-value 'message-number) number))
  (slot-value 'message-number))

(defmeth logo-proto :copyright-at-top (&optional (tnil nil set))
  (if set (setf (slot-value 'copyright-at-top) tnil))
  (slot-value 'copyright-at-top))

(defmeth logo-proto :prev-text (&optional (string nil set))
  (if set (setf (slot-value 'prev-text) string))
  (slot-value 'prev-text))

(defmeth logo-proto :comment-text (&optional (string nil set))
  (if set (setf (slot-value 'comment-text) string))
  (slot-value 'comment-text))

(defmeth logo-proto :c (&optional (list nil set))
  (if set (setf (slot-value 'c) list))
  (slot-value 'c))

(defmeth logo-proto :d (&optional (list nil set))
  (if set (setf (slot-value 'd) list))
  (slot-value 'd))

(defmeth logo-proto :e (&optional (list nil set))
  (if set (setf (slot-value 'e) list))
  (slot-value 'e))

(defmeth logo-proto :x (&optional (integer nil set))
  (if set (setf (slot-value 'x) integer))
  (slot-value 'x))

(defmeth logo-proto :y (&optional (integer nil set))
  (if set (setf (slot-value 'y) integer))
  (slot-value 'y))

(defmeth logo-proto :redraw-background () 
  (send self :back-color (send self :back-color-default)))

(defmeth logo-proto :redraw-content ()
  (let ((ok (multiple-value-list (ignore-errors (call-next-method))))
        (buf-test (remove-duplicates (send self :buffer))))
    (cond 
      ((not (send self :buffer)))
      ((send self :copyright-flag))
      ((and (= (length ok) 1)
             (not (and (= (length buf-test) 1) (not (first buf-test)))))
       (when (not (send self :glideing))
             (send self :fill-logo))
       (when (not (send self :dynamic))
             (send self :simple-write)))
      (t (format t "; Logo: redraw-content error~%")))
    nil))

(defmeth logo-proto :clear ()
  (send self :clear-lines)
  (send self :buffer nil)
  (send self :nlines 0)
  (send self :redraw))

(defmeth logo-proto :line-data (&optional c d e)
"Args: &optional (c d e)
Computes and stores, but doesnot return, standardized 3D coordinates for drawing the ViSta logo. C D and E are used to compute the curvature in the third dimension. Note that 4th dimension is added elsehere."
  (let* ((n-polygons 8);number of polygons in the logo letters
         (ndims 3)
         (c (floor (first (* 10 (uniform-rand 1)))))
         (d (floor (first (* 10 (uniform-rand 1)))))
         (e (floor (first (* 10 (uniform-rand 1))))))
    (flet ((z-val (x y) (+ (^ (- x 15 ) c) (^ (- y 6) d) (* e x y)) ))
      (let* (
         ( Vx '(0 -1 .33 ; 0 .33
               .667 1    1.333 1.667 2    
                  2.333 2.667 3 3.33 3.67 4 4.33 
                  4.66 5 6 10 15 20 25 
                  30 25 20 15 10 6.25 
                  6 5 4 3 2 1 0 ))
         ( Vy '(10 8 8.88 ;10 8.88
                7.77 6.66 5.55  4.44  3.33 
                   2.22  1.11  0 1.11 2.22 3.33 4.44 
                   5.55 6.66 10 10.2 10.4 10.6 10.8 
                   11 11 11 11 11 11 
                   10.5 8 6 4 6 8 10 ))
         ( Vz (z-val vx vy))
         ( Vax '(0 -1 .16 0))
         ( Vay '(10 8 9 10))
         ( vaz (z-val vax vay))
         ( ix '(8  10 9 9 9 9 9 8.8 8.6 8.4 8.2  8))
         ( iy '(0 1.5 1 2 3 4 5 4   3   2   1    0))
         ( iz (z-val ix iy))
         ( idotx '(9 9 10 9))
         ( idoty '(5.5 6.5 7 5.5))
         ( idotz (z-val idotx idoty))                
         ( sx '(12.6 12.6 12.8 13.4 14 16.4 18.2 
                     17.7      13.8 13.4 13 
                12.3 12.1 12 
                12   12.6 14    16   17   17.4   17.4 
                16.8 15.4 14    13   12.4 12.4 12.8
                12.2 12    11.9 12 12.2  12.5 13 14 15 16
                16.8  17.4 17.9 18.1 18.2  18.1   17.8 17.5 17 ;17.75 17.5 17
                16    15   14   13 12.8 12.7   12.6))
         ( sy (* .95 (list 8  8.5 9  9.4 9.6 9.6 8 
                   10           10 9.9 9.8 9.4 
                   9 8.6  7.6
                 7    6.2   5.3   4.7   4    3
                2   1.2   1.2   1.5   2.4 3.4   4.4
                3.8 3     2.5   2  1.3 .8 .4 .1 .1 .4
                1   1.4 2   3   3.6 4.6  5.1 5.4 5.8 ;5.0 5.4 5.8  
                6.3 6.7 7.1 7.6 7.8 7.95 8)) )   
         ( sz (z-val sx sy))
         ( tupx '(21 24 22 22 22 22 22 22 22 21.75 21.5 21.25 21))
         ( tupy '(0 1.5 1   2  3  4  5  6  7  5.25  3.5   1.75  0))
         ( tupz (z-val tupx tupy))
         ( tbarx '(21 24 21 21))
         ( tbary '(5 6 4.5 5))
         ( tbarz (z-val tbarx tbary))
         ( ax '(26 27 28 29 30 29  28 27 26))
         ( ay '( 0  2  4  2  0 3.5  7 3.5 0))
         ( az (z-val ax ay))
         ( abarx '(26 28 30 28 26 26))
         ( abary '(1.75  2.50 3.25 2.75 2.25 1.75))
         ( abarz (z-val abarx abary)))
        
    ;the :lines slot contains the coordinates for the ViSta logo
    ;lines has 24 lists, the first 3 are x,y,z for V, the next three are
    ;x,y,z for the body of i, the next are x,y,z for the dot of i, etc.
    ;the lengths of each sublist are 
    ;(35 35 35 12 12 12 4 4 4 54 54 54 13 13 13 4 4 4 9 9 9 6 6 6)
    (send self :lines 
          (list Vx (* .9 Vy) Vz            ; n=35
                ix (* .9 iy) iz            ; n=12
                idotx idoty idotz          ; n=4
                sx (* .9 sy) sz            ; n=54
                tupx (* .9 tupy) tupz      ; n=13 
                tbarx (* .9 tbary) tbarz   ; n=4
                ax (* .9 ay) az            ; n=9
                abarx (* .9 abary) abarz)) ; n=6
        ;(send self :standardize-lines)
        ;(send self :std-logo)
        (send self :c c)
        (send self :d d)
        (send self :e e)
        (list c d e)
        ))
    )
  )

#|
(defmeth logo-proto :standardize-lines ()
  (let* ((x (send self :lines))
         (nd 3)
         (np 8)
         (ni-list (select (mapcar #'length x) (* nd (iseq np))))
         )
;(break)
    (setf x-matrix 
          (transpose 
           (normalize 
            (send self :lines-supermatrix t x ni-list nd np))))
    (send self :lines (send self :lines-supermatrix 
                            nil x-matrix ni-list nd np))
    (print (mapcar #'length (send self :lines)))
    ))

(defmeth logo-proto :lines-supermatrix (direction x ni-list nd np)
"When DIRECTION is T, returns an [nl X nd] (number of lines by number of dimensions) matrix of coordinates of the linestarts specified in X. When DIRECTION is NIL does reverse process, with X specifying matrix of linestarts."
  (let* ((nl (send self :num-lines))
         (ni) (ne) (lov)
         (j 0)
         (submatrix)
         (supermatrix))
    (dotimes (i np)
             (setf ni (select ni-list i))
             (setf ne (* nd ni))
             (cond 
               (direction
                (setf submatrix (matrix (list nd ni) 
                       (select (combine x) (iseq j (+ j (1- ne))))))
                (setf supermatrix (if supermatrix (bind-columns supermatrix submatrix)
                                      submatrix)))
               (t
                (setf submatrix (select x   (iseq ni) (iseq nd) ))
                ;(pm submatrix)
                (if lov (setf lov (append lov (row-list submatrix)))
                    (setf lov (row-list submatrix)))
               ; (break)
                ))
             (setf j (+ j ne)))
    (if direction
        supermatrix
        lov)
    ))
|#
(defmeth logo-proto :fill-logo ()
  (let* ((polygon) (xy-list)
         (nb4 0)
         (n 0)
         (xyz (send self :lines))
         (nlines (send self :num-lines))
         (dc (send self :draw-color))
         (bc (send self :back-color))
         (knt 0)
         )
    (send self :draw-color (send self :draw-color-default))
    (send self :draw-color 'yellow)
    (send self :back-color (send self :back-color-default))
    (when xyz
          (send self :line-width 1)
    (dolist (i (* 3 (iseq 0 7)))
            (setf xy-list (row-list 
                      (bind-columns 
                       (select xyz i) (select xyz (1+ i)))))
            (setf n (length (select xyz i)))
            (setf ncum (+ nb4 n))
            (cond 
              ((> ncum nlines)
               ;(format t "~%; Fill Logo Error: NCUM=~d NLines=~d"ncum nlines)
               (return))
              (t
               (setf polygon
                  (mapcar 
                   #'(lambda (j)
                       (cond 
                         ((>= j nlines) 
                          (when *verbose*
                                (when (= knt 0)
                                      (format t "~%; Fill Logo error."))
                                           (setf knt (1+ knt))
                                ))
                         (t (apply #'send self :scaled-to-canvas 
                              (combine (send self :linestart-transformed-coordinate 0 j)
                                       (send self :linestart-transformed-coordinate 1 j))))))
                   (iseq nb4 (1- ncum))))
               (when (> knt 0) (format t "Aborting fill logo.~%")(return))
               (setf nb4 ncum)
               (unless (and (= (length (remove-duplicates polygon)) 1)
                            (not (first  polygon)))
                       (if (or (= i 0) (= i 9))
                           (send self :draw-color 'red)
                           (send self :draw-color 'yellow))
                       (unless (send self :wire-frame) 
                               (send self :paint-poly polygon))
                       (if (equal (send self :back-color-default) 'black)
                           (if (or (= i 0) (= i 9))
                               (send self :draw-color 'yellow)
                               (send self :draw-color 'red))
                           (send self :draw-color 'black)
                           )
                       (send self :frame-poly polygon)))))
          (send self :draw-color dc)
          (send self :back-color bc))))
    
(defmeth logo-proto :draw-logo ()
  (cond
    ((send self :use-color)
     (let ((dc (send self :draw-color))
           (bc (send self :back-color))
           (color 'blue)
           (lines (send self :lines)))
       (send self :draw-color (send self :draw-color-default))
       (send self :back-color (send self :back-color-default))
       (mapcar #'(lambda (i) 
                   (cond
                     ((= i 6) (setf color 'red)) ;3
                     ((= i 12) (setf color 'blue));9
                     ((= i 15) (setf color 'red));12
                     )
                  ; (print (list i (length (select lines i))
                  ;             (length (select lines (1+ i)))
                  ;             (length (select lines (+ i 2)))))
                   (send self :add-lines 
                         (list (select lines i) 
                               (select lines (1+ i))
                               (select lines (+ i 2))) 
                         :draw nil :width 1 :color color))
               (* 3 (iseq (floor (/ (length lines) 3)))))
       (send self :draw-color dc)
       (send self :back-color bc)
       ))
    (t
     (let ((lines (send self :lines)))
       (mapcar #'(lambda (i) 
                   (send self :add-lines 
                         (list (select lines i) 
                               (select lines (1+ i))
                               (select lines (+ i 2))) 
                         :draw nil :width 2))
               (* 3 (iseq (floor (/ (length lines) 3)))))))))


(defmeth logo-proto :get-frames-per-second (&optional spr)
  (let* ((fps)
         (start (get-internal-real-time))
         (finish nil)
         (now start)
         (elapsed 0)
         (z (identity-matrix 3))
         (k 0))
    (cond
      (*vista* (setf fps (send *vista* :frames-per-second))
               (when (not fps) (setf fps (send self :frames-per-second))))
      (t (setf fps (send self :frames-per-second))))
                
    (when (not fps)
          (when *v* (print "Calculating frames-per-second: wait for a clock tick"))
          (loop
           (setf finish (get-internal-real-time))
           (when (> finish start) (return)))
          (setf start finish)
          (setf now start)
          (when *v* 
                (print "Calculating frames-per-second: use null rotation"))
          (loop 
           (setf k (1+ k))
           
           (send self :apply-transformation z :draw nil)
           (send self :scale (iseq 4) (send self :scale (iseq 4)))
           (setf now (get-internal-real-time))
           (setf elapsed (- now start)) 
           ;(print (list k start now elapsed internal-time-units-per-second))
           (when (>= elapsed internal-time-units-per-second) (return)))
          (setf fps (round (* 1.5 k)))
          (send self :frames-per-second fps)
          (when *vista* (send *vista* :frames-per-second fps)))
    (when spr (send self :frames-per-rotation (round (* fps spr))))
    fps))
  
;4-DIMENSIONAL CHANGES IN THE GLIDE FUNCTION



(defmeth logo-proto :glide  
  (seconds-per-rotation nrotations fade-seconds direction 
                        &optional initialize-only &key (close t))
"Args: seconds-per-rotation nrotations fade-seconds direction &optional initialize-only
Glides logo towards (direction +) away (direction -), or towards then away (direction 0) over fade-seconds with nrotations at seconds-per-rotation."
  (let* (
         (frames-per-second (send self :get-frames-per-second))
         (frames-per-rotation 
          (round (* frames-per-second .5 seconds-per-rotation)))
         (fade-frames nil)
         
         (c (cos (/ pi (/ frames-per-rotation 2))))
         (s (sin (/ pi (/ frames-per-rotation 2))))
         (u (* 1 (first (- (uniform-rand 1) .5))))
         (v (* 1 (first (- (uniform-rand 1) .5))))
         (w (* 1 (first (- (uniform-rand 1) .5))))
         (x1 (* 1 (first (- (uniform-rand 1) .5))))
         (x2 (* 1 (first (- (uniform-rand 1) .5))))
         (x3 (* 1 (first (- (uniform-rand 1) .5))))
         (r (matrix '(4 4) (list 0        u  v  x1
                                 (- u)    0  w  x2
                                 (- v) (- w) 0 x3
                                 (- x1) (- x2) (- x3) 0)))
         (z (identity-matrix 4))
         (m (+ (* c z) (* s r )))
         (start (get-internal-real-time))
         (finish nil)
         (flag t)
         (elapsed 0)
         (quarter-time 0)
         (previous-elapsed 10)
         (both direction)
         (k 0))

    (send self :frames-per-rotation frames-per-rotation)
    (when (= direction 0) (setf direction 1))
    (send self :dynamic t)
    (cond 
      ((send self :transf)
       (setf m (send self :transf))
       (setf frames-per-rotation (send self :frames-per-rotation)))
      (t
       (setf c (cos (/ pi (/ frames-per-rotation 2))))
       (setf s (sin (/ pi (/ frames-per-rotation 2))))
       (setf m (+ (* c (identity-matrix 4)) (* s r )))
       (when initialize-only 
             (send self :transf m)
             )
     	 ))
    (send self :ready t)
     
    (when (not initialize-only)
          (send self :showing t)
;(when *v* (print "do the desired rotations at the determined speed"))
          
          (when (> nrotations 0)
          (dotimes (i (*  nrotations frames-per-rotation))
                   (send self :apply-transformation m :draw nil)
                   (send self :scale (iseq 4) (send self :scale (iseq 4)))))
;(when *v* (print "fade near (direction +) or away (direction -)"))
          (when (> fade-seconds 0)
                (setf fade-frames (* fade-seconds frames-per-rotation))
                (setf frames-per-rotation (floor (/ frames-per-rotation 1)))
                (setf c (cos (/ pi (/ frames-per-rotation 2))))
                (setf s (sin (/ pi (/ frames-per-rotation 2))))
                (setf m (+ (* c (identity-matrix 4)) (* s r )))
                (setf k 0)
                (setf total-iters (* fade-seconds frames-per-rotation))
                (setf scale-factor (/ 180 total-iters))
                (setf part-time (/ total-iters 3))

                ;(when (> fade-seconds 0))
                (dotimes 
                 (j fade-seconds)
                 (dotimes 
                  (i frames-per-rotation)
                  (when (> k part-time) 
                       (when (and (= both 0) flag )
                             (setf flag nil)
                             (setf direction (* -1 direction))
                             ))
                  (when (< (first (send self :scale (iseq 4))) .1) (return))
                  (when (< k (- fade-frames 5)) (setf k (1+ k)))
                  (send self :apply-transformation m :draw nil)
                  (when (> (first (send self :scale (iseq 4))) .1)
                        (send self :scale (iseq 4)
                              (* (send self :scale (iseq 4))
                                 (if (> direction 0)
                                     (/ 1 (^ (/  fade-frames (- fade-frames k)) 
                                             (* scale-factor .25)))
                                     (^ (/  fade-frames (- fade-frames k)) 
                                        (* scale-factor .06))))))      
                  )))
          (send self :dynamic nil) (send self :ready nil)
          (when close 
                (send self :close)
                )
          t)))


(defmeth logo-proto :comment (text)
  (send self :comment-text text)
  (send self :redraw))

(defmeth logo-proto :startup-comment (text)
  (when *vista-startup* (send self :comment text)))

(defun startup-comment (text)
  (send *logo* :startup-comment text))

(defmeth vista-system-object-proto :startup-remove ()
  (when *vista-startup* 
        (send *logo* :remove)
        (setf *vista-startup* nil)))

(defun startup-remove-logo ()
  (send *vista* :startup-remove))


;original definition
(defmeth logo-proto :idle-timer (&optional (max-time 3))
"arg: &optional (max-time 3) in seconds
returns nil when time is more than max-time, t when starting, 
value of :idle-on otherwise."
  (let* ((start (send self :idle-start-time))
         (now (get-internal-real-time)) 
         (elapsed))
    (cond 
      (start
       (setf elapsed (- now start))
       (when (> elapsed (* 60 max-time));60 
             (send self :idle-on nil)
             (send self :idle-start-time nil))
       (send self :idle-on))
      (t 
       (send self :idle-on t)
       (send self :idle-start-time (get-internal-real-time))
       t))))

(defmeth logo-proto :fix-it-dialog ()
  (one-button-dialog (format nil "StartUp Error.~%Fix the problem.~%Type (make-vista).~2%If (make-vista) fails:~%1: Type (exit)~%2: Trash vista.wks.~%3: Rerun ViSta.") :first-button "Fix It"))

(provide "logoobj1")
